home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / structure.scm < prev    next >
Text File  |  1999-04-19  |  3KB  |  81 lines
  1. ;;; "structure.scm" syntax-case structure macros
  2. ;;; Copyright (C) 1992 R. Kent Dybvig
  3. ;;;
  4. ;;; Permission to copy this software, in whole or in part, to use this
  5. ;;; software for any lawful purpose, and to redistribute this software
  6. ;;; is granted subject to the restriction that all copies made of this
  7. ;;; software must include this copyright notice in full.  This software
  8. ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
  9. ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  10. ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  11. ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  12. ;;; NATURE WHATSOEVER.
  13.  
  14. ;;; Written by Robert Hieb & Kent Dybvig
  15.  
  16. ;;; This file was munged by a simple minded sed script since it left
  17. ;;; its original authors' hands.  See syncase.sh for the horrid details.
  18.  
  19. ;;; structure.ss
  20. ;;; Robert Hieb & Kent Dybvig
  21. ;;; 92/06/18
  22.  
  23. (define-syntax define-structure
  24.   (lambda (x)
  25.      (define construct-name
  26.     (lambda (template-identifier . args)
  27.        (implicit-identifier
  28.           template-identifier
  29.           (string->symbol
  30.          (apply string-append
  31.             (map (lambda (x)
  32.                 (if (string? x)
  33.                     x
  34.                     (symbol->string (syntax-object->datum x))))
  35.                  args))))))
  36.      (syntax-case x ()
  37.     ((_ (name id1 ...))
  38.      (syntax (define-structure (name id1 ...) ())))
  39.     ((_ (name id1 ...) ((id2 init) ...))
  40.      (with-syntax
  41.         ((constructor (construct-name (syntax name) "make-" (syntax name)))
  42.          (predicate (construct-name (syntax name) (syntax name) "?"))
  43.          ((access ...)
  44.           (map (lambda (x) (construct-name x (syntax name) "-" x))
  45.            (syntax (id1 ... id2 ...))))
  46.          ((assign ...)
  47.           (map (lambda (x)
  48.               (construct-name x "set-" (syntax name) "-" x "!"))
  49.            (syntax (id1 ... id2 ...))))
  50.          (structure-length
  51.           (+ (length (syntax (id1 ... id2 ...))) 1))
  52.          ((index ...)
  53.           (let f ((i 1) (ids (syntax (id1 ... id2 ...))))
  54.          (if (null? ids)
  55.              '()
  56.              (cons i (f (+ i 1) (cdr ids)))))))
  57.         (syntax (begin
  58.                (define constructor
  59.               (lambda (id1 ...)
  60.                  (let* ((id2 init) ...)
  61.                 (vector 'name id1 ... id2 ...))))
  62.                (define predicate
  63.               (lambda (x)
  64.                  (and (vector? x)
  65.                   (= (vector-length x) structure-length)
  66.                   (eq? (vector-ref x 0) 'name))))
  67.                (define access
  68.               (lambda (x)
  69.                  (vector-ref x index)))
  70.                ...
  71.                ;; define macro accessors this way:
  72.                ;; (define-syntax access
  73.                ;;       (syntax-case x ()
  74.                ;;          ((_ x)
  75.                ;;           (syntax (vector-ref x index)))))
  76.                ;; ...
  77.                (define assign
  78.               (lambda (x update)
  79.                  (vector-set! x index update)))
  80.                ...)))))))
  81.